home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 4 / BBS in a Box - Macintosh - Volume IV (January 1992) (BBS in a Box).iso / Files / Prog / M / MCLUTILS.CPT / oodles-of-utils / mixin-madness / simple-view-mixins / graphic-rsrc-svm.lisp / graphic-rsrc-svm.lisp
Encoding:
Text File  |  1991-10-24  |  4.5 KB  |  127 lines  |  [TEXT/CCL2]
  1. (in-package :oou)
  2. (provide :graphic-rsrc-svm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; graphic-rsrc-svm.lisp
  5. ;;
  6. ;; Copyright © 1991 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; mixin for displaying graphical resources in views
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :rsrc-svm
  16.  :simple-view-ce)
  17.  
  18.  
  19. (export '(graphic-rsrc-svm))
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. #|
  23.  
  24. graphic-rsrc-svm adds resource based graphics to views.
  25.  
  26. See Also
  27.  rsrc-svm - inherited behavior
  28.  
  29.  
  30. Initargs
  31.  
  32.  :graphic-scaling [:adjust-view-size]
  33.    Determines if the graphic is scaled to the view size or vice-versa.
  34.    Allowed keywords are :adjust-view-size, :scale-to-view, :clip-to-view.
  35.     :adjust-view-size - the view size is adjusted to fit the graphic
  36.     :scale-to-view    - the graphic is scaled to the view size.
  37.     :clip-to-view     - the graphic is drawn clipped to the view
  38.  
  39.  
  40. Methods of Interest
  41.  
  42.  graphic-size (sv graphic-rsrc-svm) rsrc-handle
  43.   Returns the size of the specified graphic as a point.
  44.   e.g. PICT-svm's return:
  45.   (subtract-points
  46.    (href rsrc-handle :Picture.picFrame.botRight)
  47.    (href rsrc-handle :Picture.picFrame.topLeft ))
  48.  
  49.  draw-graphic (sv graphic-rsrc-svm) rsrc-handle rect
  50.    Draws the graphic scaled to rect.
  51.  
  52.  graphic-margins (sv graphic-rsrc-svm)
  53.   Returns margins for indenting the graphic as two points (topLeft, botRight).
  54.   The default method returns zero margins. Specialize this method to control
  55.   placement.
  56.  
  57. |#
  58. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59.  
  60. (defclass graphic-rsrc-svm (rsrc-svm)
  61.   ((graphic-scaling      :initarg :graphic-scaling)
  62.    (graphic-default-size :initarg :graphic-default-size))
  63.   (:default-initargs
  64.     :graphic-scaling :adjust-view-size
  65.     :graphic-default-size #@(32 32)
  66.     ))
  67.  
  68. (defmethod graphic-size ((sv graphic-rsrc-svm) rsrc-handle)
  69.   (declare (ignore rsrc-handle))
  70.   (slot-value sv 'graphic-default-size))
  71.  
  72. (defmethod draw-graphic ((sv graphic-rsrc-svm) rsrc-handle rect)
  73.   (declare (ignore sv rsrc-handle rect)))
  74.  
  75. (defmethod view-draw-contents ((sv graphic-rsrc-svm))
  76.   (with-slots (rsrc-handle) sv
  77.     (multiple-value-bind (topLeft botRight) (graphic-corners sv)
  78.       (ecase (slot-value sv 'graphic-scaling)
  79.         (:scale-to-view (rlet ((r :Rect :topLeft topLeft :botRight botRight))
  80.                           (draw-graphic sv rsrc-handle r)))
  81.         (:adjust-view-size (rlet ((r :Rect
  82.                                      :topLeft topLeft
  83.                                      :botRight (add-points topLeft (graphic-size sv rsrc-handle))))
  84.                              (draw-graphic sv rsrc-handle r)))
  85.         (:clip-to-view (rlet ((clip-rect :Rect
  86.                                          :topLeft topLeft
  87.                                          :botRight botRight)
  88.                               (r :Rect :topLeft topLeft :botRight (add-points topLeft (graphic-size sv rsrc-handle))))
  89.                          (with-clip-rect clip-rect
  90.                            (draw-graphic sv rsrc-handle r)))))))
  91.   (call-next-method))
  92.  
  93. (defmethod graphic-margins ((sv graphic-rsrc-svm))
  94.   (declare (ignore sv))
  95.   (values #@(0 0) #@(0 0)))
  96.  
  97. (defmethod graphic-corners ((sv graphic-rsrc-svm))
  98.   (multiple-value-bind (topLeft botRight) (focused-corners sv)
  99.     (multiple-value-bind (tl-margin br-margin) (graphic-margins sv)
  100.       (values (add-points topLeft tl-margin) (subtract-points botRight br-margin)))))
  101.  
  102. (defmethod view-default-size ((sv graphic-rsrc-svm))
  103.   (add-points (multiple-value-call #'add-points (graphic-margins sv))
  104.               (slot-value sv 'graphic-default-size)))
  105.  
  106. (defmethod scale-view-size ((sv graphic-rsrc-svm))
  107.   (when (slot-boundp sv 'rsrc-handle)
  108.     (with-slots (rsrc-handle) sv
  109.       (let ((margin-size (multiple-value-call #'add-points (graphic-margins sv))))
  110.         (set-view-size sv (add-points (graphic-size sv rsrc-handle) margin-size))))))
  111.  
  112. (defmethod set-view-size :before ((sv graphic-rsrc-svm) h &optional v)
  113.   (declare (ignore h v))
  114.   (erase-view sv))
  115.  
  116. (defmethod rsrc-handle-install :after ((sv graphic-rsrc-svm))
  117.   (if (eq :adjust-view-size (slot-value sv 'graphic-scaling))
  118.     (scale-view-size sv)
  119.     (invalidate-view sv t)))
  120.  
  121. (defmethod set-view-resource :after ((sv graphic-rsrc-svm)  &key rsrc-type rsrc-id rsrc-name rsrc-handle)
  122.   (declare (ignore rsrc-type rsrc-id rsrc-name rsrc-handle))
  123.   (invalidate-view sv t))
  124.  
  125.  
  126. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  127.